; ORIGINAL: 3dt2.1/examples/describe.scm
; $Id: describe.scm,v 1.3 1996/10/21 15:59:01 aed Exp $
;- describe.scm -------------------------------------------------------
;; @(#)describe.scm	1.309/15/94
;
; Describe a scheme object
;----------------------------------------------------------------------
(define (describe x)
  (fluid-let
    ((print-depth 2)
     (print-length 3))
    (format #t "~s is " (if (eq? x #v) '\#v x)))
  (case (type x)
    (integer
      (format #t "an integer.~%"))
    (real
      (format #t "a real.~%"))
    (null
      (format #t "an empty list.~%"))
    (boolean
      (format #t "a boolean value (~s).~%" (if x 'true 'false)))
    (character
      (format #t "a character, ascii value is ~s~%" (char->integer x)))
    (symbol
      (format #t "a symbol.")
      (let ((l (symbol-plist x)))
        (if (null? l)
            (format #t "  It has no property list.~%")
            (format #t "~%Its property list is: ~s.~%" l))))
    (pair
      (if (pair? (cdr x))
          (let ((p (last-pair x)))
            (if (null? (cdr p))
                (format #t "a list of length ~s.~%" (length x))
                (format #t "an improper list.~%")))
          (format #t "a pair (cons cell).~%")))
    (environment
      (format #t "an environment.~%"))
    (string
      (if (eqv? x "")
          (format #t "an empty string.~%")
          (format #t "a string of length ~s.~%" (string-length x))))
    (vector
      (if (eqv? x '#())
          (format #t "an empty vector.~%")
          (if (and (feature? 'oops) (memq (vector-ref x 0)
                                          '(class instance)))
              (if (eq? (vector-ref x 0) 'class)
                  (begin
                    (format #t "a class.~%~%")
                    (describe-class x))
                  (format #t "an instance.~%~%")
                  (describe-instance x))
              (format #t "a vector of length ~s.~%" (vector-length x)))))
    (primitive
      (format #t "a primitive procedure.~%"))
    (compound
      (format #t "a compound procedure (type ~s).~%"
              (car (procedure-lambda x))))
    (control-point
      (format #t "a control point (continuation).~%"))
    (promise
      (format #t "a promise.~%"))
    (port
      (format #t "a port.~%"))
    (end-of-file
      (format #t "the end-of-file object.~%"))
    (macro
      (format #t "a macro.~%"))
    (entity
      (format #t "an entity of type ~s~%" (entity:debug x)))
    (position
      (format #t "a position.~%"))
    (gvector
      (format #t "an ACIS vector.~%"))
    (view
      (format #t "a view. ~%"))
    (color
      (format #t "a color. ~%"))
    (curve
      (format #t "a curve. ~%"))
    (else
      (let ((descr-func (string->symbol
                          (format #f "describe-~s" (type x)))))
        (if (bound? descr-func)
            ((eval descr-func) x)
            (format #t "an object of unknown type (~s)~%" (type x)))))))

